#|
Copyright (c) 2005-2009, Marc Feeley
All rights reserved.

Redistribution and use in source and binary forms, with or
without modification, are permitted provided that the
following conditions are met:

* Redistributions of source code must retain the above
copyright notice, this list of conditions and the following
disclaimer.

* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials
provided with the distribution.

* The name of the author may not be used to endorse or promote
products derived from this software without specific prior
written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|#

;;; Contains procedures to compute message digests.

(##namespace ("digest#"))
(##include "~~lib/gambit#.scm")
(include "digest#.scm")

(declare
 (standard-bindings)
 (extended-bindings)
 (not inline)
 (not safe))

(define-macro (fx+ . args) `(##fx+ ,@args))
(define-macro (fx- . args) `(##fx- ,@args))
(define-macro (fx* . args) `(##fx* ,@args))
(define-macro (fxquotient . args) `(##fxquotient ,@args))
(define-macro (fxmin . args) `(##fxmin ,@args))
(define-macro (fx= . args) `(##fx= ,@args))
(define-macro (fx< . args) `(##fx< ,@args))
(define-macro (fx> . args) `(##fx> ,@args))
(define-macro (fx<= . args) `(##fx<= ,@args))
(define-macro (fx>= . args) `(##fx>= ,@args))
(define-macro (fxnot . args) `(##fxnot ,@args))
(define-macro (fxand . args) `(##fxand ,@args))
(define-macro (fxior . args) `(##fxior ,@args))
(define-macro (fxxor . args) `(##fxxor ,@args))
(define-macro (fxarithmetic-shift-right . args) `(##fxarithmetic-shift-right ,@args))
(define-macro (fxarithmetic-shift-left . args) `(##fxarithmetic-shift-left ,@args))
(define-macro (make-vector . args) `(##make-vector ,@args))
(define-macro (make-u8vector . args) `(##make-u8vector ,@args))
(define-macro (u8vector . args) `(##u8vector ,@args))
(define-macro (u8vector-length . args) `(##u8vector-length ,@args))
(define-macro (u8vector-ref . args) `(##u8vector-ref ,@args))
(define-macro (u8vector-set! . args) `(##u8vector-set! ,@args))
(define-macro (read-subu8vector . args) `(##read-subu8vector ,@args))
(define-macro (string-append . args) `(##string-append ,@args))
(define-macro (make-string . args) `(##make-string ,@args))
(define-macro (open-input-file . args) `(##open-input-file ,@args))
(define-macro (close-input-port . args) `(##close-input-port ,@args))
(define-macro (number->string . args) `(##number->string ,@args))

;;;----------------------------------------------------------------------------

(define-type digest
  id: digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
  end
  update
  state)

;;;----------------------------------------------------------------------------

;; CRC32 digest.

(define-type crc32-digest
  id: crc32-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
  hi16
  lo16)

(define crc32-table '#(
#x0000 #x0000 #x7707 #x3096 #xEE0E #x612C #x9909 #x51BA
#x076D #xC419 #x706A #xF48F #xE963 #xA535 #x9E64 #x95A3
#x0EDB #x8832 #x79DC #xB8A4 #xE0D5 #xE91E #x97D2 #xD988
#x09B6 #x4C2B #x7EB1 #x7CBD #xE7B8 #x2D07 #x90BF #x1D91
#x1DB7 #x1064 #x6AB0 #x20F2 #xF3B9 #x7148 #x84BE #x41DE
#x1ADA #xD47D #x6DDD #xE4EB #xF4D4 #xB551 #x83D3 #x85C7
#x136C #x9856 #x646B #xA8C0 #xFD62 #xF97A #x8A65 #xC9EC
#x1401 #x5C4F #x6306 #x6CD9 #xFA0F #x3D63 #x8D08 #x0DF5
#x3B6E #x20C8 #x4C69 #x105E #xD560 #x41E4 #xA267 #x7172
#x3C03 #xE4D1 #x4B04 #xD447 #xD20D #x85FD #xA50A #xB56B
#x35B5 #xA8FA #x42B2 #x986C #xDBBB #xC9D6 #xACBC #xF940
#x32D8 #x6CE3 #x45DF #x5C75 #xDCD6 #x0DCF #xABD1 #x3D59
#x26D9 #x30AC #x51DE #x003A #xC8D7 #x5180 #xBFD0 #x6116
#x21B4 #xF4B5 #x56B3 #xC423 #xCFBA #x9599 #xB8BD #xA50F
#x2802 #xB89E #x5F05 #x8808 #xC60C #xD9B2 #xB10B #xE924
#x2F6F #x7C87 #x5868 #x4C11 #xC161 #x1DAB #xB666 #x2D3D
#x76DC #x4190 #x01DB #x7106 #x98D2 #x20BC #xEFD5 #x102A
#x71B1 #x8589 #x06B6 #xB51F #x9FBF #xE4A5 #xE8B8 #xD433
#x7807 #xC9A2 #x0F00 #xF934 #x9609 #xA88E #xE10E #x9818
#x7F6A #x0DBB #x086D #x3D2D #x9164 #x6C97 #xE663 #x5C01
#x6B6B #x51F4 #x1C6C #x6162 #x8565 #x30D8 #xF262 #x004E
#x6C06 #x95ED #x1B01 #xA57B #x8208 #xF4C1 #xF50F #xC457
#x65B0 #xD9C6 #x12B7 #xE950 #x8BBE #xB8EA #xFCB9 #x887C
#x62DD #x1DDF #x15DA #x2D49 #x8CD3 #x7CF3 #xFBD4 #x4C65
#x4DB2 #x6158 #x3AB5 #x51CE #xA3BC #x0074 #xD4BB #x30E2
#x4ADF #xA541 #x3DD8 #x95D7 #xA4D1 #xC46D #xD3D6 #xF4FB
#x4369 #xE96A #x346E #xD9FC #xAD67 #x8846 #xDA60 #xB8D0
#x4404 #x2D73 #x3303 #x1DE5 #xAA0A #x4C5F #xDD0D #x7CC9
#x5005 #x713C #x2702 #x41AA #xBE0B #x1010 #xC90C #x2086
#x5768 #xB525 #x206F #x85B3 #xB966 #xD409 #xCE61 #xE49F
#x5EDE #xF90E #x29D9 #xC998 #xB0D0 #x9822 #xC7D7 #xA8B4
#x59B3 #x3D17 #x2EB4 #x0D81 #xB7BD #x5C3B #xC0BA #x6CAD
#xEDB8 #x8320 #x9ABF #xB3B6 #x03B6 #xE20C #x74B1 #xD29A
#xEAD5 #x4739 #x9DD2 #x77AF #x04DB #x2615 #x73DC #x1683
#xE363 #x0B12 #x9464 #x3B84 #x0D6D #x6A3E #x7A6A #x5AA8
#xE40E #xCF0B #x9309 #xFF9D #x0A00 #xAE27 #x7D07 #x9EB1
#xF00F #x9344 #x8708 #xA3D2 #x1E01 #xF268 #x6906 #xC2FE
#xF762 #x575D #x8065 #x67CB #x196C #x3671 #x6E6B #x06E7
#xFED4 #x1B76 #x89D3 #x2BE0 #x10DA #x7A5A #x67DD #x4ACC
#xF9B9 #xDF6F #x8EBE #xEFF9 #x17B7 #xBE43 #x60B0 #x8ED5
#xD6D6 #xA3E8 #xA1D1 #x937E #x38D8 #xC2C4 #x4FDF #xF252
#xD1BB #x67F1 #xA6BC #x5767 #x3FB5 #x06DD #x48B2 #x364B
#xD80D #x2BDA #xAF0A #x1B4C #x3603 #x4AF6 #x4104 #x7A60
#xDF60 #xEFC3 #xA867 #xDF55 #x316E #x8EEF #x4669 #xBE79
#xCB61 #xB38C #xBC66 #x831A #x256F #xD2A0 #x5268 #xE236
#xCC0C #x7795 #xBB0B #x4703 #x2202 #x16B9 #x5505 #x262F
#xC5BA #x3BBE #xB2BD #x0B28 #x2BB4 #x5A92 #x5CB3 #x6A04
#xC2D7 #xFFA7 #xB5D0 #xCF31 #x2CD9 #x9E8B #x5BDE #xAE1D
#x9B64 #xC2B0 #xEC63 #xF226 #x756A #xA39C #x026D #x930A
#x9C09 #x06A9 #xEB0E #x363F #x7207 #x6785 #x0500 #x5713
#x95BF #x4A82 #xE2B8 #x7A14 #x7BB1 #x2BAE #x0CB6 #x1B38
#x92D2 #x8E9B #xE5D5 #xBE0D #x7CDC #xEFB7 #x0BDB #xDF21
#x86D3 #xD2D4 #xF1D4 #xE242 #x68DD #xB3F8 #x1FDA #x836E
#x81BE #x16CD #xF6B9 #x265B #x6FB0 #x77E1 #x18B7 #x4777
#x8808 #x5AE6 #xFF0F #x6A70 #x6606 #x3BCA #x1101 #x0B5C
#x8F65 #x9EFF #xF862 #xAE69 #x616B #xFFD3 #x166C #xCF45
#xA00A #xE278 #xD70D #xD2EE #x4E04 #x8354 #x3903 #xB3C2
#xA767 #x2661 #xD060 #x16F7 #x4969 #x474D #x3E6E #x77DB
#xAED1 #x6A4A #xD9D6 #x5ADC #x40DF #x0B66 #x37D8 #x3BF0
#xA9BC #xAE53 #xDEBB #x9EC5 #x47B2 #xCF7F #x30B5 #xFFE9
#xBDBD #xF21C #xCABA #xC28A #x53B3 #x9330 #x24B4 #xA3A6
#xBAD0 #x3605 #xCDD7 #x0693 #x54DE #x5729 #x23D9 #x67BF
#xB366 #x7A2E #xC461 #x4AB8 #x5D68 #x1B02 #x2A6F #x2B94
#xB40B #xBE37 #xC30C #x8EA1 #x5A05 #xDF1B #x2D02 #xEF8D
))

(define (digest-update-crc32 digest u8vect start end)
  (let ((state (digest-state digest)))
    (let ((hi16 (crc32-digest-hi16 state))
          (lo16 (crc32-digest-lo16 state)))
      (let loop ((i start)
                 (hi hi16)
                 (lo lo16))
        (if (fx< i end)
            (let* ((x (u8vector-ref u8vect i))
                   (j (fx* 2 (fxand (fxxor lo x) #xff)))
                   (crc-hi (vector-ref crc32-table j))
                   (crc-lo (vector-ref crc32-table (fx+ j 1))))
              (loop (fx+ i 1)
                    (fxxor
                     crc-hi
                     (fxarithmetic-shift-right hi 8))
                    (fxxor
                     crc-lo
                     (fx+ (fxarithmetic-shift-left (fxand hi #xff) 8)
                          (fxarithmetic-shift-right lo 8)))))
            (begin
              (crc32-digest-hi16-set! state hi)
              (crc32-digest-lo16-set! state lo)))))))

(define (end-crc32 digest result-type)

  (define (hex16 n) ;; assumes n is a fixnum
    (let* ((s (number->string n 16))
           (len (string-length s)))
      (if (fx= len 4)
          s
          (string-append (make-string (fx- 4 len) #\0) s))))

  (let ((state (digest-state digest)))
    (let ((hi16 (fxxor (crc32-digest-hi16 state) #xffff))
          (lo16 (fxxor (crc32-digest-lo16 state) #xffff)))
      (case result-type
        ((hex)
         (string-append (hex16 hi16) (hex16 lo16)))
        ((u8vector)
         (u8vector (fxand #xff lo16)
                   (fxarithmetic-shift-right lo16 8)
                   (fxand #xff hi16)
                   (fxarithmetic-shift-right hi16 8)))
        (else
         (error "unsupported digest result-type" result-type))))))

(define (open-digest-crc32)
  (make-digest
   end-crc32
   digest-update-crc32
   (make-crc32-digest #xffff #xffff)))

;; Useful for debugging:

#;
(begin

(namespace ("" arithmetic-shift bitwise-and bitwise-xor))

(define crc32-poly #xEDB88320)

(define crc32-table-computed
  (let ((v (make-vector 512)))
    (let loop1 ((n 0))
      (if (fx< n 256)
          (let loop2 ((k 0) (c n))
            (if (fx< k 8)
                (loop2 (fx+ k 1)
                       (if (odd? c)
                           (bitwise-xor crc32-poly
                                        (arithmetic-shift c -1))
                           (arithmetic-shift c -1)))
                (begin
                  (vector-set! v (fx* n 2) (arithmetic-shift c -16))
                  (vector-set! v (fx+ 1 (fx* n 2)) (bitwise-and c #xffff))
                  (loop1 (fx+ n 1)))))))
    v))

(if (not (equal? crc32-table-computed crc32-table))
    (error "crc32-table is incorrect"))

#;
(define (digest-update-crc32 digest u8vect start end)
  (let ((state (digest-state digest)))
    (let ((hi16 (crc32-digest-hi16 state))
          (lo16 (crc32-digest-lo16 state)))
      (let loop ((i start)
                 (crc (fx+ (arithmetic-shift hi16 16)
                           lo16)))
        (if (fx< i end)
            (let* ((x (u8vector-ref u8vect i))
                   (crc (bitwise-xor crc x)))
              (let loop2 ((j 8) (crc crc))
                (if (fx> j 0)
                    (loop2 (fx- j 1)
                           (if (odd? crc)
                               (bitwise-xor crc32-poly
                                            (arithmetic-shift crc -1))
                               (arithmetic-shift crc -1)))
                    (loop (fx+ i 1)
                          crc))))
            (begin
              (crc32-digest-hi16-set!
               state
               (arithmetic-shift crc -16))
              (crc32-digest-lo16-set!
               state
               (bitwise-and crc #xffff))))))))
)

;;;----------------------------------------------------------------------------

(define (hash-block->hex-string hb big-endian? width)

  (define (hex x)
    (string-ref "0123456789abcdef" (fxand x 15)))

  (let* ((len (fxquotient width 16))
         (n (fx* len 4))
         (str (make-string n)))
    (let loop ((i (fx- len 1)) (j (fx- n 4)))
      (if (fx< i 0)
          str
          (let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
                (j1 (if big-endian? (fx+ j 0) (fx+ j 2)))
                (j2 (if big-endian? (fx+ j 2) (fx+ j 0))))
            (string-set!
             str
             (fx+ j1 0)
             (hex (fxarithmetic-shift-right x 12)))
            (string-set!
             str
             (fx+ j1 1)
             (hex (fxarithmetic-shift-right x 8)))
            (string-set!
             str
             (fx+ j2 0)
             (hex (fxarithmetic-shift-right x 4)))
            (string-set!
             str
             (fx+ j2 1)
             (hex (fxarithmetic-shift-right x 0)))
            (loop (fx- i 1) (fx- j 4)))))))

(define (hash-block->u8vector hb big-endian? width)
  (let* ((len (fxquotient width 16))
         (n (fx* len 2))
         (u8vect (make-u8vector n 0)))
    (let loop ((i (fx- len 1)) (j (fx- n 2)))
      (if (fx< i 0)
          u8vect
          (let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
                (j1 (if big-endian? (fx+ j 0) (fx+ j 1)))
                (j2 (if big-endian? (fx+ j 1) (fx+ j 0))))
            (u8vector-set! u8vect j1 (fxarithmetic-shift-right x 8))
            (u8vector-set! u8vect j2 (fxand #xff x))
            (loop (fx- i 1) (fx- j 2)))))))

(define-macro (LO var)
  (string->symbol
   (string-append (symbol->string var) "-" (symbol->string 'L))))

(define-macro (HI var)
  (string->symbol
   (string-append (symbol->string var) "-" (symbol->string 'H))))

(define-macro (wlet var lo hi body)
  `(let ((,(string->symbol
            (string-append (symbol->string var) "-" (symbol->string 'L)))
          ,lo)
         (,(string->symbol
            (string-append (symbol->string var) "-" (symbol->string 'H)))
          ,hi))
     ,body))

(define-macro (cast-u16 x)
  `(fxand #xffff ,x))

(define-macro (shift-left-u16 n shift)
  `(fxarithmetic-shift-left
    (fxand ,n ,(fx- (expt 2 (fx- 16 shift)) 1))
    ,shift))

(define-macro (wshr dst w r body)
  (if (fx< r 16)
      `(wlet ,dst
             (fxior
              (fxarithmetic-shift-right (LO ,w) ,r)
              (shift-left-u16 (HI ,w) ,(fx- 16 r)))
             (fxarithmetic-shift-right (HI ,w) ,r)
             ,body)
      `(wlet ,dst
             (fxarithmetic-shift-right (HI ,w) ,(fx- r 16))
             0
             ,body)))

(define-macro (wrot dst w r body)
  (if (fx< r 16)
      `(wlet ,dst
             (fxior
              (shift-left-u16 (LO ,w) ,r)
              (fxarithmetic-shift-right (HI ,w) ,(fx- 16 r)))
             (fxior
              (shift-left-u16 (HI ,w) ,r)
              (fxarithmetic-shift-right (LO ,w) ,(fx- 16 r)))
             ,body)
      `(wlet ,dst
             (fxior
              (shift-left-u16 (HI ,w) ,(fx- r 16))
              (fxarithmetic-shift-right (LO ,w) ,(fx- 32 r)))
             (fxior
              (shift-left-u16 (LO ,w) ,(fx- r 16))
              (fxarithmetic-shift-right (HI ,w) ,(fx- 32 r)))
             ,body)))

(define-macro (wadd dst a b body)
  `(wlet R
         (fx+ (LO ,a) (LO ,b))
         (fx+ (HI ,a) (HI ,b))
         (wlet ,dst
               (cast-u16 (LO R))
               (cast-u16
                (fx+ (HI R)
                     (fxarithmetic-shift-right (LO R) 16)))
               ,body)))

(define-macro (wxor dst a b body)
  `(wlet ,dst
         (fxxor (LO ,a) (LO ,b))
         (fxxor (HI ,a) (HI ,b))
         ,body))

(define-macro (wior dst a b body)
  `(wlet ,dst
         (fxior (LO ,a) (LO ,b))
         (fxior (HI ,a) (HI ,b))
         ,body))

(define-macro (wand dst a b body)
  `(wlet ,dst
         (fxand (LO ,a) (LO ,b))
         (fxand (HI ,a) (HI ,b))
         ,body))

(define-macro (wnot dst a body)
  `(wlet ,dst
         (fxnot (LO ,a))
         (fxnot (HI ,a))
         ,body))

(define-macro (wref dst v i body)
  (if (number? i)
      `(wlet ,dst
             (vector-ref ,v ,(fx+ (fx* 2 i) 0))
             (vector-ref ,v ,(fx+ (fx* 2 i) 1))
             ,body)
      `(wlet ,dst
             (vector-ref ,v (fx+ (fx* 2 ,i) 0))
             (vector-ref ,v (fx+ (fx* 2 ,i) 1))
             ,body)))

(define-macro (wset v i x)
  (if (number? i)
      `(begin
         (vector-set! ,v ,(fx+ (fx* 2 i) 0) (LO ,x))
         (vector-set! ,v ,(fx+ (fx* 2 i) 1) (HI ,x)))
      `(begin
         (vector-set! ,v (fx+ (fx* 2 ,i) 0) (LO ,x))
         (vector-set! ,v (fx+ (fx* 2 ,i) 1) (HI ,x)))))

;;;----------------------------------------------------------------------------

(define-type block-digest
  id: block-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
  hash-update
  hash
  block
  block-pos
  bit-pos
  big-endian?
  width)

(define (convert-hash-block digest result-type)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd)))
    (case result-type
      ((hex)
       (hash-block->hex-string
        hash
        (block-digest-big-endian? bd)
        (block-digest-width bd)))
      ((u8vector)
       (hash-block->u8vector
        hash
        (block-digest-big-endian? bd)
        (block-digest-width bd)))
      (else
       (error "unsupported digest result-type" result-type)))))

(define (process-last-block digest)
  (let* ((bd
          (digest-state digest))
         (block-pos
          (block-digest-block-pos bd))
         (bit-pos
          (block-digest-bit-pos bd))
         (buf
          (make-u8vector 8 0)))

    (digest-update-u8 digest #x80) ;; add byte-aligned 1 bit

    (let ((zero-padding-bytes
           (fxquotient
            (fxand 511 (fx- 448 (block-digest-bit-pos bd)))
            8)))
      (let loop1 ((n zero-padding-bytes))
        (if (fx< 0 n)
            (let ((m (fxmin 8 n)))
              (digest-update-subu8vector
               digest
               buf
               0
               m) ;; add 0 bits
              (loop1 (fx- n m))))))

    (u8vector-set!
     buf
     0
     (fxand #xff bit-pos))

    (u8vector-set!
     buf
     1
     (fxior
      (fxarithmetic-shift-left (fxand #x7f block-pos) 1)
      (fxand #x01 (fxarithmetic-shift-right bit-pos 8))))

    (let loop2 ((i 2)
                (n (fxarithmetic-shift-right block-pos 7)))
      (if (fx> n 0)
          (begin
            (u8vector-set! buf i (fxand #xff n))
            (loop2 (fx+ i 1)
                   (fxarithmetic-shift-right n 8)))))

    (if (block-digest-big-endian? bd)
        (let loop3 ((i 3))
          (if (fx>= i 0)
              (let ((t (u8vector-ref buf i)))
                (u8vector-set! buf i (u8vector-ref buf (fx- 7 i)))
                (u8vector-set! buf (fx- 7 i) t)
                (loop3 (fx- i 1))))))

    (digest-update-subu8vector digest buf 0 8)));; add message length (in bits)

(define (end-block-digest digest result-type)
  (process-last-block digest)
  (convert-hash-block digest result-type))

(define (digest-update-block-digest digest u8vect start end)
  (let* ((bd (digest-state digest))
         (block (block-digest-block bd)))

    (define (aligned8 i bit-pos)

      ;; bit-pos is a multiple of 8

      (if (fx< i end)
          (let ((j (fxarithmetic-shift-right bit-pos 4)))
            (if (fx= 0 (fxand bit-pos 15))
                (begin
                  (if (block-digest-big-endian? bd)
                      (let ((j (fxxor j 1)))
                        (vector-set!
                         block
                         j
                         (fxarithmetic-shift-left
                          (u8vector-ref u8vect i)
                          8)))
                      (vector-set!
                       block
                       j
                       (u8vector-ref u8vect i)))
                  (let ((new-bit-pos (fx+ bit-pos 8)))
                    (aligned8 (fx+ i 1) new-bit-pos)))
                (begin
                  (if (block-digest-big-endian? bd)
                      (let ((j (fxxor j 1)))
                        (vector-set!
                         block
                         j
                         (fx+ (vector-ref block j)
                              (u8vector-ref u8vect i))))
                      (vector-set!
                       block
                       j
                       (fx+ (vector-ref block j)
                            (fxarithmetic-shift-left
                             (u8vector-ref u8vect i)
                             8))))
                  (let ((new-bit-pos (fx+ bit-pos 8)))
                    (if (fx= 512 new-bit-pos)
                      (begin
                        ((block-digest-hash-update bd) digest)
                        (block-digest-block-pos-set!
                         bd
                         (fx+ (block-digest-block-pos bd) 1))
                        (aligned16 (fx+ i 1) 0))
                      (aligned16 (fx+ i 1) new-bit-pos))))))
          (block-digest-bit-pos-set! bd bit-pos)))

    (define (aligned16 i bit-pos)

      ;; bit-pos is a multiple of 16

      (if (fx< (fx+ i 1) end)
          (let ((j (fxarithmetic-shift-right bit-pos 4)))
            (if (block-digest-big-endian? bd)
                (let ((j (fxxor j 1)))
                  (vector-set!
                   block
                   j
                   (fx+
                    (fxarithmetic-shift-left
                     (u8vector-ref u8vect i)
                     8)
                    (u8vector-ref u8vect (fx+ i 1)))))
                (vector-set!
                 block
                 j
                 (fx+
                  (fxarithmetic-shift-left
                   (u8vector-ref u8vect (fx+ i 1))
                   8)
                  (u8vector-ref u8vect i))))
            (let ((new-bit-pos (fx+ bit-pos 16)))
              (if (fx= 512 new-bit-pos)
                  (begin
                    ((block-digest-hash-update bd) digest)
                    (block-digest-block-pos-set!
                     bd
                     (fx+ (block-digest-block-pos bd) 1))
                    (aligned16 (fx+ i 2) 0))
                  (aligned16 (fx+ i 2) new-bit-pos))))
          (aligned8 i bit-pos)))

    (let ((bit-pos (block-digest-bit-pos bd)))
      (cond ((fx= 0 (fxand bit-pos 15)) ;; 16 bit boundary?
             (aligned16 start bit-pos))
            (else
             ;; (fx= 0 (fxand bit-pos 7)) ;; 8 bit boundary?
             (aligned8 start bit-pos))))))

;;;----------------------------------------------------------------------------

;; MD5 digest.

(define (hash-block-init-md5)
  (vector #x2301 #x6745
          #xab89 #xefcd
          #xdcfe #x98ba
          #x5476 #x1032))

(define-macro (wstp dst w f i n-hi16 n-lo16 r body)
  `(wlet T1
         ,(cons (car f) (map (lambda (v) `(LO ,v)) (cdr f)))
         ,(cons (car f) (map (lambda (v) `(HI ,v)) (cdr f)))
   (wadd T2 ,dst T1
   (wref T3 block ,i
   (wadd T4 T2 T3
   (wlet T5
         ,n-lo16
         ,n-hi16
   (wadd T6 T4 T5
   (wrot T7 T6 ,r
   (wadd ,dst ,w T7
         ,body)))))))))

(define-macro (fn-F x y z)
  `(fxior
    (fxand ,x ,y)
    (fxand (fxnot ,x) ,z)))

(define-macro (fn-G x y z)
  `(fxior
    (fxand ,x ,z)
    (fxand ,y (fxnot ,z))))

(define-macro (fn-H x y z)
  `(fxxor ,x (fxxor ,y ,z)))

(define-macro (fn-I x y z)
  `(cast-u16
    (fxxor
     ,y
     (fxior
      ,x
      (fxnot ,z)))))

(define (digest-update-md5 digest)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd))
         (block (block-digest-block bd)))

    (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-F B C D)  0 #xD76A #xA478  7
      (wstp D A (fn-F A B C)  1 #xE8C7 #xB756 12
      (wstp C D (fn-F D A B)  2 #x2420 #x70DB 17
      (wstp B C (fn-F C D A)  3 #xC1BD #xCEEE 22
      (wstp A B (fn-F B C D)  4 #xF57C #x0FAF  7
      (wstp D A (fn-F A B C)  5 #x4787 #xC62A 12
      (wstp C D (fn-F D A B)  6 #xA830 #x4613 17
      (wstp B C (fn-F C D A)  7 #xFD46 #x9501 22
      (stage2 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-F B C D)  8 #x6980 #x98D8  7
      (wstp D A (fn-F A B C)  9 #x8B44 #xF7AF 12
      (wstp C D (fn-F D A B) 10 #xFFFF #x5BB1 17
      (wstp B C (fn-F C D A) 11 #x895C #xD7BE 22
      (wstp A B (fn-F B C D) 12 #x6B90 #x1122  7
      (wstp D A (fn-F A B C) 13 #xFD98 #x7193 12
      (wstp C D (fn-F D A B) 14 #xA679 #x438E 17
      (wstp B C (fn-F C D A) 15 #x49B4 #x0821 22
      (stage3 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-G B C D)  1 #xF61E #x2562  5
      (wstp D A (fn-G A B C)  6 #xC040 #xB340  9
      (wstp C D (fn-G D A B) 11 #x265E #x5A51 14
      (wstp B C (fn-G C D A)  0 #xE9B6 #xC7AA 20
      (wstp A B (fn-G B C D)  5 #xD62F #x105D  5
      (wstp D A (fn-G A B C) 10 #x0244 #x1453  9
      (wstp C D (fn-G D A B) 15 #xD8A1 #xE681 14
      (wstp B C (fn-G C D A)  4 #xE7D3 #xFBC8 20
      (stage4 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-G B C D)  9 #x21E1 #xCDE6  5
      (wstp D A (fn-G A B C) 14 #xC337 #x07D6  9
      (wstp C D (fn-G D A B)  3 #xF4D5 #x0D87 14
      (wstp B C (fn-G C D A)  8 #x455A #x14ED 20
      (wstp A B (fn-G B C D) 13 #xA9E3 #xE905  5
      (wstp D A (fn-G A B C)  2 #xFCEF #xA3F8  9
      (wstp C D (fn-G D A B)  7 #x676F #x02D9 14
      (wstp B C (fn-G C D A) 12 #x8D2A #x4C8A 20
      (stage5 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-H B C D)  5 #xFFFA #x3942  4
      (wstp D A (fn-H A B C)  8 #x8771 #xF681 11
      (wstp C D (fn-H D A B) 11 #x6D9D #x6122 16
      (wstp B C (fn-H C D A) 14 #xFDE5 #x380C 23
      (wstp A B (fn-H B C D)  1 #xA4BE #xEA44  4
      (wstp D A (fn-H A B C)  4 #x4BDE #xCFA9 11
      (wstp C D (fn-H D A B)  7 #xF6BB #x4B60 16
      (wstp B C (fn-H C D A) 10 #xBEBF #xBC70 23
      (stage6 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-H B C D) 13 #x289B #x7EC6  4
      (wstp D A (fn-H A B C)  0 #xEAA1 #x27FA 11
      (wstp C D (fn-H D A B)  3 #xD4EF #x3085 16
      (wstp B C (fn-H C D A)  6 #x0488 #x1D05 23
      (wstp A B (fn-H B C D)  9 #xD9D4 #xD039  4
      (wstp D A (fn-H A B C) 12 #xE6DB #x99E5 11
      (wstp C D (fn-H D A B) 15 #x1FA2 #x7CF8 16
      (wstp B C (fn-H C D A)  2 #xC4AC #x5665 23
      (stage7 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-I B C D)  0 #xF429 #x2244  6
      (wstp D A (fn-I A B C)  7 #x432A #xFF97 10
      (wstp C D (fn-I D A B) 14 #xAB94 #x23A7 15
      (wstp B C (fn-I C D A)  5 #xFC93 #xA039 21
      (wstp A B (fn-I B C D) 12 #x655B #x59C3  6
      (wstp D A (fn-I A B C)  3 #x8F0C #xCC92 10
      (wstp C D (fn-I D A B) 10 #xFFEF #xF47D 15
      (wstp B C (fn-I C D A)  1 #x8584 #x5DD1 21
      (stage8 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-I B C D)  8 #x6FA8 #x7E4F  6
      (wstp D A (fn-I A B C) 15 #xFE2C #xE6E0 10
      (wstp C D (fn-I D A B)  6 #xA301 #x4314 15
      (wstp B C (fn-I C D A) 13 #x4E08 #x11A1 21
      (wstp A B (fn-I B C D)  4 #xF753 #x7E82  6
      (wstp D A (fn-I A B C) 11 #xBD3A #xF235 10
      (wstp C D (fn-I D A B)  2 #x2AD7 #xD2BB 15
      (wstp B C (fn-I C D A)  9 #xEB86 #xD391 21
      (stage9 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wref AA hash 0 (wadd A AA A (wset hash 0 A)))
      (wref BB hash 1 (wadd B BB B (wset hash 1 B)))
      (wref CC hash 2 (wadd C CC C (wset hash 2 C)))
      (wref DD hash 3 (wadd D DD D (wset hash 3 D))))

    (wref A hash 0
    (wref B hash 1
    (wref C hash 2
    (wref D hash 3
    (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)))))))

(define (open-digest-md5)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-md5
    (hash-block-init-md5)
    (make-vector 32 0)
    0
    0
    #f
    128)))

;;;----------------------------------------------------------------------------

;; SHA-1 digest.

(define (hash-block-init-sha-1)
  (vector #x2301 #x6745
          #xab89 #xefcd
          #xdcfe #x98ba
          #x5476 #x1032
          #xe1f0 #xc3d2))

(define (digest-update-sha-1 digest)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd))
         (block (block-digest-block bd)))
    (wref OLDA hash 0
    (wref OLDB hash 1
    (wref OLDC hash 2
    (wref OLDD hash 3
    (wref OLDE hash 4
    (let loop ((j 0)
               (A-L OLDA-L) (A-H OLDA-H)
               (B-L OLDB-L) (B-H OLDB-H)
               (C-L OLDC-L) (C-H OLDC-H)
               (D-L OLDD-L) (D-H OLDD-H)
               (E-L OLDE-L) (E-H OLDE-H))

      (define (stage1)
        (if (fx< j 16)

            (wref T1 block j
            (stage2 T1-L T1-H))

            (wref T1 block (fx- j 3)
            (wref T2 block (fx- j 8)
            (wxor T3 T1 T2
            (wref T4 block (fx- j 14)
            (wxor T5 T3 T4
            (wref T6 block (fx- j 16)
            (wxor T7 T5 T6
            (wrot X T7 1
            (begin
              (wset block j X)
              (stage2 X-L X-H))))))))))))

      (define (stage2 X-L X-H)
        (cond ((fx< j 20)
               (wand T1 B C
               (wnot T2 B
               (wand T3 D T2
               (wior T4 T1 T3
               (wlet T5 #x7999 #x5a82
               (wadd T6 T4 T5
               (stage3 X-L X-H T6-L T6-H))))))))
              ((fx< j 40)
               (wxor T1 B C
               (wxor T2 D T1
               (wlet T3 #xeba1 #x6ed9
               (wadd T4 T2 T3
               (stage3 X-L X-H T4-L T4-H))))))
              ((fx< j 60)
               (wand T1 B C
               (wand T2 B D
               (wior T3 T1 T2
               (wand T4 C D
               (wior T5 T3 T4
               (wlet T6 #xbcdc #x8f1b
               (wadd T7 T5 T6
               (stage3 X-L X-H T7-L T7-H)))))))))
              (else
               (wxor T1 B C
               (wxor T2 D T1
               (wlet T3 #xc1d6 #xca62
               (wadd T4 T2 T3
               (stage3 X-L X-H T4-L T4-H))))))))

      (define (stage3 X-L X-H Y-L Y-H)
        (wrot T1 A 5
        (wadd T2 E T1
        (wadd T3 X T2
        (wadd T4 Y T3
        (wrot T5 B 30
        (loop (fx+ j 1)
              T4-L T4-H
              A-L A-H
              T5-L T5-H
              C-L C-H
              D-L D-H)))))))

      (if (fx< j 80)

          (stage1)

          (begin
            (wadd NEWA A OLDA (wset hash 0 NEWA))
            (wadd NEWB B OLDB (wset hash 1 NEWB))
            (wadd NEWC C OLDC (wset hash 2 NEWC))
            (wadd NEWD D OLDD (wset hash 3 NEWD))
            (wadd NEWE E OLDE (wset hash 4 NEWE))))))))))))

(define (open-digest-sha-1)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-sha-1
    (hash-block-init-sha-1)
    (make-vector 160 0)
    0
    0
    #t
    160)))

;;;----------------------------------------------------------------------------

;; SHA-224 and SHA-256 digests.

(define (hash-block-init-sha-224)
  (vector #x9ed8 #xc105
          #xd507 #x367c
          #xdd17 #x3070
          #x5939 #xf70e
          #x0b31 #xffc0
          #x1511 #x6858
          #x8fa7 #x64f9
          #x4fa4 #xbefa))

(define (hash-block-init-sha-256)
  (vector #xe667 #x6a09
          #xae85 #xbb67
          #xf372 #x3c6e
          #xf53a #xa54f
          #x527f #x510e
          #x688c #x9b05
          #xd9ab #x1f83
          #xcd19 #x5be0))

(define-macro (fn-W dst i body)
  `(wref ,dst block ,i ,body))

(define-macro (fn-R dst i body)
  `(wref T1 block ,(fx- i 15) ;; compute S0
   (wrot T2 T1 25
   (wrot T3 T1 14
   (wxor T4 T2 T3
   (wshr T5 T1 3
   (wxor S0 T4 T5
   (wref T6 block ,(fx- i 2) ;; compute S1
   (wrot T7 T6 15
   (wrot T8 T6 13
   (wxor T9 T7 T8
   (wshr T10 T6 10
   (wxor S1 T9 T10
   (wadd T11 S0 S1 ;; compute sum
   (wref T12 block ,(fx- i 7)
   (wadd T13 T11 T12
   (wref T14 block ,(fx- i 16)
   (wadd ,dst T13 T14
   (begin (wset block ,i ,dst)
   ,body)))))))))))))))))))

(define-macro (fn-P a b c d e f g h x i k-hi16 k-lo16 body)
  `(wrot T1 ,a 30 ;; compute S2
   (wrot T2 ,a 19
   (wxor T3 T1 T2
   (wrot T4 ,a 10
   (wxor S2 T3 T4
   (wrot T5 ,e 26 ;; compute S3
   (wrot T6 ,e 21
   (wxor T7 T5 T6
   (wrot T8 ,e 7
   (wxor S3 T7 T8
   (wior T9 ,a ,b ;; compute F0
   (wand T10 ,c T9
   (wand T11 ,a ,b
   (wior F0 T10 T11
   (wxor T12 ,f ,g ;; compute F1
   (wand T13 ,e T12
   (wxor F1 ,g T13
   (,x T14 ,i ;; compute (fn-W i) or (fn-R i)
   (wadd T15 T14 S3 ;; compute sum
   (wadd T16 F1 T15
   (wlet T17 ,k-lo16 ,k-hi16
   (wadd T18 T16 T17
   (wadd T19 ,h T18
   (wadd T20 S2 F0
   (wadd ,d T19 ,d
   (wadd ,h T19 T20
   ,body)))))))))))))))))))))))))))

(define (digest-update-sha-256 digest)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd))
         (block (block-digest-block bd)))

    (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-W  0 #x428A #x2F98
      (fn-P H A B C D E F G fn-W  1 #x7137 #x4491
      (fn-P G H A B C D E F fn-W  2 #xB5C0 #xFBCF
      (fn-P F G H A B C D E fn-W  3 #xE9B5 #xDBA5
      (fn-P E F G H A B C D fn-W  4 #x3956 #xC25B
      (fn-P D E F G H A B C fn-W  5 #x59F1 #x11F1
      (fn-P C D E F G H A B fn-W  6 #x923F #x82A4
      (fn-P B C D E F G H A fn-W  7 #xAB1C #x5ED5
      (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-W  8 #xD807 #xAA98
      (fn-P H A B C D E F G fn-W  9 #x1283 #x5B01
      (fn-P G H A B C D E F fn-W 10 #x2431 #x85BE
      (fn-P F G H A B C D E fn-W 11 #x550C #x7DC3
      (fn-P E F G H A B C D fn-W 12 #x72BE #x5D74
      (fn-P D E F G H A B C fn-W 13 #x80DE #xB1FE
      (fn-P C D E F G H A B fn-W 14 #x9BDC #x06A7
      (fn-P B C D E F G H A fn-W 15 #xC19B #xF174
      (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 16 #xE49B #x69C1
      (fn-P H A B C D E F G fn-R 17 #xEFBE #x4786
      (fn-P G H A B C D E F fn-R 18 #x0FC1 #x9DC6
      (fn-P F G H A B C D E fn-R 19 #x240C #xA1CC
      (fn-P E F G H A B C D fn-R 20 #x2DE9 #x2C6F
      (fn-P D E F G H A B C fn-R 21 #x4A74 #x84AA
      (fn-P C D E F G H A B fn-R 22 #x5CB0 #xA9DC
      (fn-P B C D E F G H A fn-R 23 #x76F9 #x88DA
      (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 24 #x983E #x5152
      (fn-P H A B C D E F G fn-R 25 #xA831 #xC66D
      (fn-P G H A B C D E F fn-R 26 #xB003 #x27C8
      (fn-P F G H A B C D E fn-R 27 #xBF59 #x7FC7
      (fn-P E F G H A B C D fn-R 28 #xC6E0 #x0BF3
      (fn-P D E F G H A B C fn-R 29 #xD5A7 #x9147
      (fn-P C D E F G H A B fn-R 30 #x06CA #x6351
      (fn-P B C D E F G H A fn-R 31 #x1429 #x2967
      (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 32 #x27B7 #x0A85
      (fn-P H A B C D E F G fn-R 33 #x2E1B #x2138
      (fn-P G H A B C D E F fn-R 34 #x4D2C #x6DFC
      (fn-P F G H A B C D E fn-R 35 #x5338 #x0D13
      (fn-P E F G H A B C D fn-R 36 #x650A #x7354
      (fn-P D E F G H A B C fn-R 37 #x766A #x0ABB
      (fn-P C D E F G H A B fn-R 38 #x81C2 #xC92E
      (fn-P B C D E F G H A fn-R 39 #x9272 #x2C85
      (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 40 #xA2BF #xE8A1
      (fn-P H A B C D E F G fn-R 41 #xA81A #x664B
      (fn-P G H A B C D E F fn-R 42 #xC24B #x8B70
      (fn-P F G H A B C D E fn-R 43 #xC76C #x51A3
      (fn-P E F G H A B C D fn-R 44 #xD192 #xE819
      (fn-P D E F G H A B C fn-R 45 #xD699 #x0624
      (fn-P C D E F G H A B fn-R 46 #xF40E #x3585
      (fn-P B C D E F G H A fn-R 47 #x106A #xA070
      (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 48 #x19A4 #xC116
      (fn-P H A B C D E F G fn-R 49 #x1E37 #x6C08
      (fn-P G H A B C D E F fn-R 50 #x2748 #x774C
      (fn-P F G H A B C D E fn-R 51 #x34B0 #xBCB5
      (fn-P E F G H A B C D fn-R 52 #x391C #x0CB3
      (fn-P D E F G H A B C fn-R 53 #x4ED8 #xAA4A
      (fn-P C D E F G H A B fn-R 54 #x5B9C #xCA4F
      (fn-P B C D E F G H A fn-R 55 #x682E #x6FF3
      (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (fn-P A B C D E F G H fn-R 56 #x748F #x82EE
      (fn-P H A B C D E F G fn-R 57 #x78A5 #x636F
      (fn-P G H A B C D E F fn-R 58 #x84C8 #x7814
      (fn-P F G H A B C D E fn-R 59 #x8CC7 #x0208
      (fn-P E F G H A B C D fn-R 60 #x90BE #xFFFA
      (fn-P D E F G H A B C fn-R 61 #xA450 #x6CEB
      (fn-P C D E F G H A B fn-R 62 #xBEF9 #xA3F7
      (fn-P B C D E F G H A fn-R 63 #xC671 #x78F2
      (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))

    (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
                    E-L E-H F-L F-H G-L G-H H-L H-H)
      (wref OLDA hash 0 (wadd NEWA A OLDA (wset hash 0 NEWA)))
      (wref OLDB hash 1 (wadd NEWB B OLDB (wset hash 1 NEWB)))
      (wref OLDC hash 2 (wadd NEWC C OLDC (wset hash 2 NEWC)))
      (wref OLDD hash 3 (wadd NEWD D OLDD (wset hash 3 NEWD)))
      (wref OLDE hash 4 (wadd NEWE E OLDE (wset hash 4 NEWE)))
      (wref OLDF hash 5 (wadd NEWF F OLDF (wset hash 5 NEWF)))
      (wref OLDG hash 6 (wadd NEWG G OLDG (wset hash 6 NEWG)))
      (wref OLDH hash 7 (wadd NEWH H OLDH (wset hash 7 NEWH))))

    (wref A hash 0
    (wref B hash 1
    (wref C hash 2
    (wref D hash 3
    (wref E hash 4
    (wref F hash 5
    (wref G hash 6
    (wref H hash 7
    (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
            E-L E-H F-L F-H G-L G-H H-L H-H)))))))))))

(define (open-digest-sha-224)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-sha-256
    (hash-block-init-sha-224)
    (make-vector 160 0)
    0
    0
    #t
    224)))

(define (open-digest-sha-256)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-sha-256
    (hash-block-init-sha-256)
    (make-vector 160 0)
    0
    0
    #t
    256)))

;;;----------------------------------------------------------------------------

(define (open-digest algorithm)
  (case algorithm 
    ((crc32 CRC32)
     (open-digest-crc32))
    ((md5 MD5)
     (open-digest-md5))
    ((sha-1 SHA-1)
     (open-digest-sha-1))
    ((sha-224 SHA-224)
     (open-digest-sha-224))
    ((sha-256 SHA-256)
     (open-digest-sha-256))
;;    ((sha-384 SHA-384)
;;     (open-digest-sha-384))
;;    ((sha-512 SHA-512)
;;     (open-digest-sha-512))
    (else
     (error "unknown hashing algorithm" algorithm))))

(define-macro (digest-default-result-type) ''hex)

(define (close-digest
         digest
         #!optional
         (result-type (digest-default-result-type)))
  ((digest-end digest) digest result-type))

(define (digest-update-subu8vector digest u8vect start end)
  ((digest-update digest) digest u8vect start end))

(define zero-u8vector (make-u8vector 4 0))

(define (get-zero-u8vector) zero-u8vector)

(define (digest-update-u8 digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (make-u8vector 1 (fxand n #xff)))
   0
   1))

(define (digest-update-u16-le digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (make-u8vector 2)))
         (u8vector-set!
          u8vect
          0
          (fxand n #xff))
         (u8vector-set!
          u8vect
          1
          (fxand (fxarithmetic-shift-right n 8) #xff))
         u8vect))
   0
   2))

(define (digest-update-u16-be digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (make-u8vector 2)))
         (u8vector-set!
          u8vect
          1
          (fxand n #xff))
         (u8vector-set!
          u8vect
          0
          (fxand (fxarithmetic-shift-right n 8) #xff))
         u8vect))
   0
   2))

(define (digest-update-u32-le digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (make-u8vector 4)))
         (u8vector-set!
          u8vect
          0
          (fxand n #xff))
         (u8vector-set!
          u8vect
          1
          (fxand (fxarithmetic-shift-right n 8) #xff))
         (u8vector-set!
          u8vect
          2
          (fxand (fxarithmetic-shift-right n 16) #xff))
         (u8vector-set!
          u8vect
          3
          (fxand (fxarithmetic-shift-right n 24) #xff))
         u8vect))
   0
   4))

(define (digest-update-u32-be digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (make-u8vector 4)))
         (u8vector-set!
          u8vect
          3
          (fxand n #xff))
         (u8vector-set!
          u8vect
          2
          (fxand (fxarithmetic-shift-right n 8) #xff))
         (u8vector-set!
          u8vect
          1
          (fxand (fxarithmetic-shift-right n 16) #xff))
         (u8vector-set!
          u8vect
          0
          (fxand (fxarithmetic-shift-right n 24) #xff))
         u8vect))
   0
   4))

(define (digest-string
         str
         algorithm
         #!optional
         (result-type (digest-default-result-type)))
  (digest-substring
   str
   0
   (string-length str)
   algorithm
   result-type))

(define (digest-substring
         str
         start
         end
         algorithm
         #!optional
         (result-type (digest-default-result-type)))
  (let* ((len (fx- end start))
         (u8vect (make-u8vector len)))
    (let loop ((i 0))
      (if (fx< i len)
          (begin
            (u8vector-set! u8vect i (char->integer (string-ref str i)))
            (loop (fx+ i 1)))
          (digest-subu8vector u8vect 0 len algorithm result-type)))))

(define (digest-u8vector
         u8vect
         algorithm
         #!optional
         (result-type (digest-default-result-type)))
  (digest-subu8vector
   u8vect
   0
   (u8vector-length u8vect)
   algorithm
   result-type))

(define (digest-subu8vector
         u8vect
         start
         end
         algorithm
         #!optional
         (result-type (digest-default-result-type)))
  (let ((digest (open-digest algorithm)))
    (digest-update-subu8vector digest u8vect start end)
    (close-digest digest result-type)))

(define (digest-file
         filename
         algorithm
         #!optional
         (result-type (digest-default-result-type)))
  (let ((digest (open-digest algorithm)))
    (let* ((in (open-input-file filename))
           (bufsize 1024)
           (buf (make-u8vector bufsize)))
      (let loop ()
        (let ((n (read-subu8vector buf 0 bufsize in)))
          (if (fx= n 0)
              (begin
                (close-input-port in)
                (close-digest digest result-type))
              (begin
                (digest-update-subu8vector digest buf 0 n)
                (loop))))))))

;;;----------------------------------------------------------------------------

;; Self tests.

#;
(begin

 (define crc32-test-vectors
   '(
     ("" 0 ""
      "00000000")
     ("" 0 "a"
      "e8b7be43")
     ("" 0 "abc"
      "352441c2")
     ("" 0 "abcdefghijklmnopqrstuvwxyz"
      "4c2750bd")
     ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
      "1fc2e6d2")
     ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
      "7ca94a72")
     ))

 (define md5-test-vectors
   '(
     ;; from RFC 1321:
     ("" 0 ""
      "d41d8cd98f00b204e9800998ecf8427e")
     ("" 0 "a"
      "0cc175b9c0f1b6a831c399e269772661")
     ("" 0 "abc"
      "900150983cd24fb0d6963f7d28e17f72")
     ("" 0 "message digest"
      "f96b697d7cb7938d525a2f31aaf161d0")
     ("" 0 "abcdefghijklmnopqrstuvwxyz"
      "c3fcd3d76192e4007dfb496cca67e13b")
     ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
      "d174ab98d277d9f5a5611c2c9f419d9f")
     ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
      "57edf4a22be3c955ac49da2e2107b67a")
     ))

 (define sha-1-test-vectors
   '(
     ("" 0 ""
      "da39a3ee5e6b4b0d3255bfef95601890afd80709")
     ;; from RFC 3174:
     ("" 0 "abc"
      "a9993e364706816aba3e25717850c26c9cd0d89d")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "84983e441c3bd26ebaae4aa1f95129e5e54670f1")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
     ("0123456701234567012345670123456701234567012345670123456701234567" 10 ""
      "dea356a2cddd90c7a7ecedc5ebb563934f460452")
     ))

 (define sha-224-test-vectors
   '(
     ;; from RFC 3874:
     ("" 0 "abc"
      "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67")
    ))

 (define sha-256-test-vectors
   '(
     ("" 0 ""
      "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
     ;; from FIPS-180-2:
     ("" 0 "abc"
      "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")
    ))

 (define (test-digest)

   (define (t algorithm vectors)

     (namespace ("" pp list->u8vector))

     (for-each
      (lambda (v)
        (let ((str1 (car v))
              (repeat (cadr v))
              (str2 (caddr v))
              (expect (cadddr v)))
          (let ((md
                 (if (fx= repeat 0)
                     (digest-string str2 algorithm 'hex)
                     (let ((u8vect1
                            (list->u8vector
                             (map char->integer (string->list str1))))
                           (u8vect2
                            (list->u8vector
                             (map char->integer (string->list str2))))
                           (digest
                            (open-digest algorithm)))
                       (let loop ((i 0))
                         (if (fx< i repeat)
                             (begin
                               (digest-update-subu8vector
                                digest
                                u8vect1
                                0
                                (u8vector-length u8vect1))
                               (loop (fx+ i 1)))
                             (begin
                               (digest-update-subu8vector
                                digest
                                u8vect2
                                0
                                (u8vector-length u8vect2))
                               (close-digest digest 'hex))))))))
            (if (not (string-ci=? md expect))
                (pp (list '***error*** md expect))))))
      vectors))

   (t 'crc32 crc32-test-vectors)
   (t 'md5 md5-test-vectors)
   (t 'sha-1 sha-1-test-vectors)
   (t 'sha-224 sha-224-test-vectors)
   (t 'sha-256 sha-256-test-vectors)
)

 (test-digest))

;;;============================================================================
